home *** CD-ROM | disk | FTP | other *** search
- Unit Mode13h;
-
- { Version 1.1 }
-
- Interface
-
- Const VGA=$A000;
- Npages=3;
-
- Type RgbItem=Record
- R,G,B:Byte;
- End;
- RgbList=Array[0..255] of RgbItem;
- Table=Array[0..1799] Of Real;
- PTable=^Table;
-
- Var Sines:Ptable;
- Cosines:Ptable;
- Virt:Array[1..Npages] Of Pointer;
- VP:Array[1..Npages] Of Word;
-
- Procedure Initgraph;
- Procedure Closegraph;
- Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
- Function GetPixel(X,Y:word;Where:Word):Byte;
- Procedure Cls(Col:Byte;Where:Word);
- Procedure WaitVBL;
- Procedure GetColor(Col:Byte;Var R,G,B:Byte);
- Procedure SetColor(Col,R,G,B:Byte);
- Procedure GetPalette(Var Pal:RgbList);
- Procedure SetPalette(Pal:RgbList);
- Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
- Procedure Fade(Target:RgbList);
- Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
- Function Sgn(A:Real):Integer;
- Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
- Procedure InitTables;
- Procedure ClearTables;
- Procedure InitVirt;
- Procedure CloseVirt;
- Procedure CopyPage(From,Too:Word);
- Procedure LoadPCX(Filename:String;Where:Word);
-
- Implementation
-
- Procedure Initgraph; Assembler;
- Asm
- mov ah,0
- mov al,13h
- int 10h
- End;
-
- Procedure Closegraph; Assembler;
- Asm
- mov ah,0
- mov al,03h
- int 10h
- End;
-
- Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
- Begin
- Mem[Where:(y*320)+x]:=Col;
- End;
-
- Function GetPixel(X,Y:word;Where:Word):Byte;
- Begin
- GetPixel:=Mem[Where:(y*320)+x];
- End;
-
-
- Procedure Cls(Col:Byte;Where:Word);
- Begin
- Fillchar(Mem[Where:0000],64000,Col);
- End;
-
- Procedure WaitVBL; Assembler;
- Label A1,A2;
- Asm
- Mov DX,3DAh
- A1:
- In AL,DX
- And AL,08h
- Jnz A1
- A2:
- In AL,DX
- And AL,08h
- Jz A2
- End;
-
- Procedure GetColor(Col:Byte;Var R,G,B:Byte);
- Begin
- Port[$3C7]:=Col;
- R:=Port[$3C9];
- G:=Port[$3C9];
- B:=Port[$3C9];
- End;
-
- Procedure SetColor(Col,R,G,B:Byte);
- Begin
- Port[$3C8]:=Col;
- Port[$3C9]:=R;
- Port[$3C9]:=G;
- Port[$3C9]:=B;
- End;
-
- Procedure GetPalette(Var Pal:RgbList);
- Var A:Byte;
- Begin
- For A:=0 To 255 do GetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
- End;
-
- Procedure SetPalette(Pal:RgbList);
- Var A:Byte;
- Begin
- WaitVBL;
- For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
- End;
-
- Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
- Var Temp:RgbItem;
- A:Byte;
- Begin
- Temp:=Pal[Last];
- For A:=Last-1 DownTo First Do Pal[A+1]:=Pal[A];
- Pal[First]:=Temp;
- End;
-
- Procedure Fade(Target:RgbList);
- Var Tmp:RgbList;
- Flag:Boolean;
- Loop:Integer;
- Begin
- Repeat
- Flag:=True;
- GetPalette(Tmp);
- For Loop:=0 To 255 Do
- Begin
- If Tmp[Loop].R>Target[Loop].R Then
- Begin
- Dec(Tmp[Loop].R);
- Flag:=False;
- End;
- If Tmp[Loop].G>Target[Loop].G Then
- Begin
- Dec(Tmp[Loop].G);
- Flag:=False;
- End;
- If Tmp[Loop].B>Target[Loop].B Then
- Begin
- Dec(Tmp[Loop].B);
- Flag:=False;
- End;
- If Tmp[Loop].R<Target[Loop].R Then
- Begin
- Inc(Tmp[Loop].R);
- Flag:=False;
- End;
- If Tmp[Loop].G<Target[Loop].G Then
- Begin
- Inc(Tmp[Loop].G);
- Flag:=False;
- End;
- If Tmp[Loop].B<Target[Loop].B Then
- Begin
- Inc(Tmp[Loop].B);
- Flag:=False;
- End;
- End;
- SetPalette(Tmp);
- Until Flag;
- End;
-
- Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
- Var Px,Py:Integer;
- Deg:Word;
- Begin
- For Deg:=0 to 1799 Do
- Begin
- Px:=Trunc(R*Sines^[Deg]+X);
- Py:=Trunc(R*Cosines^[Deg]+Y);
- PutPixel(Px,Py,Col,Where);
- End;
- End;
-
- Function Sgn(A:Real):Integer;
- Begin
- If A<0 then Sgn:=-1;
- If A=0 then Sgn:=0;
- If A>0 then Sgn:=+1;
- End;
-
- Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
- Var Deltax,S,Deltay,Dx1,Dy1,Dx2,Dy2,S1,S2:Real;
- I:Integer;
- Begin
- Deltax:=X2-X1;
- Deltay:=Y2-Y1;
- Dx1:=Sgn(Deltax);
- Dy1:=Sgn(Deltay);
- Dx2:=Sgn(Deltax);
- Dy2:= 0;
- S1:=Abs(Deltax);
- S2:=Abs(Deltay);
- If Not (S1>S2) Then
- Begin
- Dx2:=0;
- Dy2:=Sgn(Deltay);
- S1:=Abs(Deltay);
- S2:=Abs(Deltax);
- End;
- S:=Int(S1/2);
- For I:=0 To Round(S1) Do
- Begin
- PutPixel(X1,Y1,Col,Where);
- S:=S+S2;
- If Not (S<S1) Then
- Begin
- S:=S-S1;
- X1:=X1+Round(Dx1);
- Y1:=Y1+Round(Dy1);
- End
- Else
- Begin
- X1:=X1+Round(dx2);
- Y1:=Y1+Round(Dy2);
- End;
- End;
- End;
-
- Procedure InitTables;
- Var A:Word;
- B:Real;
- Begin
- Getmem(Sines,Sizeof(Sines^));
- Getmem(Cosines,Sizeof(Cosines^));
- B:=0;
- For A:=0 To 1799 Do
- Begin
- Sines^[A]:=Sin(B);
- Cosines^[A]:=Cos(B);
- B:=B+0.005;
- End;
- End;
-
- Procedure ClearTables;
- Begin
- Freemem(Sines,Sizeof(Sines^));
- Freemem(Cosines,Sizeof(Cosines^));
- End;
-
- Procedure InitVirt;
- Var A:Byte;
- Begin
- For A:=1 To Npages Do
- Begin
- GetMem(Virt[A],64000);
- VP[A]:=Seg(Virt[A]^);
- End;
- End;
-
- Procedure CloseVirt;
- Var A:Byte;
- Begin
- For A:=1 To Npages Do
- Begin
- Freemem(Virt[A],64000);
- VP[A]:=$A000;
- End;
- End;
-
- Procedure CopyPage(From,Too:Word);
- Begin
- WaitVbl;
- Move(Mem[From:0],Mem[Too:0],64000);
- End;
-
- Procedure LoadPCX(Filename:String;Where:Word);
- Var Fil:File;
- Dx,Dy:Word;
- J,M:Byte;
- Ph:Word;
- Buff:Array[0..127] of byte;
- PCXPal:RgbList;
- Begin
- Assign(Fil,Filename);
- Reset(Fil,1);
- Blockread(Fil,Buff,128);
- Dy:=0;
- Repeat
- Dx:=0;
- Repeat
- BlockRead(Fil,J,1);
- If J>192 Then
- Begin
- BlockRead(Fil,M,1);
- Dec(J,192);
- For Ph:=1 To J Do
- Begin
- PutPixel(Dx,Dy,M,Where);
- Inc(Dx);
- End;
- End
- Else
- Begin
- PutPixel(Dx,Dy,J,Where);
- Inc(Dx);
- End;
- Until Dx>=320;
- Inc(Dy);
- Until Dy=200;
- BlockRead(Fil,M,1);
- If M=12 Then
- Begin
- BlockRead(Fil,PCXPal,768);
- For M:=0 To 255 Do
- Begin
- PCXPal[M].R:=PCXPal[M].R Div 4;
- PCXPal[M].G:=PCXPal[M].G Div 4;
- PCXPal[M].B:=PCXPal[M].B Div 4;
- End;
- SetPalette(PCXPal);
- End;
- Close(Fil);
- End;
-
- Begin
- End.